unit main;

interface

type
  TBenchFunc = function: Integer;

 procedure RunBenchmarks;

 function Bench(message:string; testFunc: TBenchFunc; mSecs:Integer=10): Int64;

implementation

uses
  SysUtils, Variants, fncs;//, thrds, Windows;

function TestCPUTime: Integer;
var
  i: Integer;
begin
  Result := 1000;
  for i := 1 to Result do
    CPUTime;
end;

function TestForLoop: Integer;
var
  i: Integer;
begin
  Result := 1000;
  for i := 1 to Result do;
end;

function TestWhileLoop: Integer;
begin
  Result := 0;
  while Result < 1000 do
    Inc(Result);
end;

function TestInterlockedIncrement: Integer;
begin
  Result := 0;
  while Result < 1000 do
    InterlockedIncrement(Result);
end;

function TestCAS: Integer;
begin
  Result := 0;
  while Result < 1000 do
    if InterlockedCompareExchange(Result, Result+1, Result)=Result then;
end;

function TestVariantCall: Integer;
  procedure IncVar(var v:Variant);
  begin
    Inc(TVarData(v).vint64, 1);
    v := v + 1;
  end;
var
  v: Variant;
begin
  v := 0;
  while v < 1000 do
    IncVar(v);
  Result := v;
end;

function TestStaticFunc: Integer;
  function DummyInc(v:Integer): Integer;
  begin
    Result := v + 1;
  end;
begin
  Result := 0;
  while Result < 1000 do
     Result := DummyInc(Result);
end;

function TestStaticProc: Integer;
  procedure DummyInc(var v:Integer);
  begin
    v := v + 1;
  end;
begin
  Result := 0;
  while Result < 1000 do
    DummyInc(Result);
end;

//function TestCriticalSection: Integer;
//var
//  i: Integer;
//  cs: IMutex;
//begin
//  cs := CriticalSection;
//  for i := 1 to 1000 do begin
//    cs.Lock;
//    cs.Unlock;
//  end;
//  Result := 1000;
//end;

type
  { This benchmarks Object and Inteface methods call modes }
  IDummy = interface ['{2758596D-8BE3-41F0-8828-35A2774FDE0B}']
    function StaticInc(v:Integer): Integer;
    function VirtualInc(v:Integer): Integer;
  end;

  TDummyObj = class(TInterfacedObject, IDummy)
    function StaticInc(v:Integer): Integer;
    function VirtualInc(v:Integer): Integer; virtual;
  end;

function TDummyObj.StaticInc(v: Integer): Integer;
begin
  Result := v + 1;
end;

function TDummyObj.VirtualInc(v: Integer): Integer;
begin
  Result := v + 1;
end;

function TestStaticObject: Integer;
var
  dummy: TDummyObj;
begin
  dummy := TDummyObj.Create;

  Result := 0;
  while Result < 1000 do
    Result := dummy.StaticInc(Result);
  dummy.Free;
end;

function TestStaticInterface: Integer;
var
  dummy: IDummy;
begin
  dummy := TDummyObj.Create as IDummy;

  Result := 0;
  while Result < 1000 do
    Result := dummy.StaticInc(Result);
end;

function TestVirtualObject: Integer;
var
  dummy: TDummyObj;
begin
  dummy := TDummyObj.Create;

  Result := 0;
  while Result < 1000 do
    Result := dummy.VirtualInc(Result);
  dummy.Free;
end;

function TestVirtualInterface: Integer;
var
  dummy: IDummy;
begin
  Result := 0;
  dummy := TDummyObj.Create as IDummy;
  while Result < 1000 do
    Result := dummy.VirtualInc(Result);
end;

{ --------------------------------------------------------------------------------------- }

const
  M: Int64 = 1000*1000;

{ Execute [proc] for [time] and return the number of operations per second }
function Bench(message:string; testFunc:TBenchFunc; mSecs:Integer): Int64;
var
  stopTime: Int64;
begin
  Result := 0;
  stopTime := CPUTime + (CPUFrequency * mSecs) div 1000;
  while CPUTime < stopTime do
    Inc(Result, testFunc() );
  Result := Result * 1000 div mSecs;
  Writeln(message, Format('%6.0d', [CPUFrequency div Result]), ' ', Format('%6.0d', [Result div M]));
end;

procedure RunBenchmarks;
begin
  SetPriority(ppCritical);
  WriteLn('CPU: ', CPUCores, ' cores ', FormatFloat(',0', CPUFrequency/M),' MHz');
  WriteLn;

  WriteLn('Operation                 Cycles   MOPS');
  WriteLn('------------------------- ------ ------');

  Bench('for loop                  ', @TestForLoop);
  Bench('while loop                ', @TestWhileLoop);
  Bench('CPUTime                   ', @TestCPUTime);
  Bench('InterlockedIncrement      ', @TestInterlockedIncrement);
  Bench('InterlockedCompareExchange', @TestCAS);
  //Bench('CriticalSection           ', @TestCriticalSection);
  Bench('Variant Call              ', @TestVariantCall);

  WriteLn;
  WriteLn('Call modes ------------------------------');
  Bench('Static Procedure          ', @TestStaticProc);
  Bench('Static Function           ', @TestStaticFunc);
  Bench('Object static             ', @TestStaticObject);
  Bench('Interface static          ', @TestStaticInterface);
  Bench('Object virtual            ', @TestVirtualObject);
  Bench('Interface virtual         ', @TestVirtualInterface);

  WriteLn;
  WriteLn('Press [Enter] to quit');
  ReadLn;
end;

end.

